home *** CD-ROM | disk | FTP | other *** search
/ TestDrive Windows 1993 Fall / TestDrive Windows 1993 Fall.iso / dbase / samples / orders.frg < prev    next >
Encoding:
Text File  |  1993-03-09  |  7.8 KB  |  388 lines
  1. * Program............: orders.FRG
  2. * Date...............: 3-09-93
  3. * Versions...........: dBASE IV, Report 2.0
  4. *
  5. * Notes:
  6. * ------
  7. * Prior to running this procedure with the DO command
  8. * it is necessary use LOCATE because the CONTINUE
  9. * statement is in the main loop.
  10. *
  11. *-- Parameters
  12. PARAMETERS gl_noeject, gl_plain, gl_summary, gc_heading, gc_extra
  13. ** The first three parameters are of type Logical.
  14. ** The fourth parameter is a string.  The fifth is extra.
  15. PRIVATE _peject, _wrap, ll_heading
  16. ll_heading = .F.
  17.  
  18. *-- Test for no records found
  19. IF EOF() .OR. .NOT. FOUND()
  20.    RETURN
  21. ENDIF
  22.  
  23. *-- turn word wrap mode off
  24. _wrap=.F.
  25.  
  26. IF _plength < (_pspacing * 4 + 1) + (_pspacing * 3 + 1) + 2
  27.    SET DEVICE TO SCREEN
  28.    DEFINE WINDOW gw_report FROM 7,17 TO 11,62 DOUBLE
  29.    ACTIVATE WINDOW gw_report
  30.    @ 0,1 SAY "Increase the page length for this report."
  31.    @ 2,1 SAY "Press any key ..."
  32.    x=INKEY(0)
  33.    DEACTIVATE WINDOW gw_report
  34.    RELEASE WINDOW gw_report
  35.    RETURN
  36. ENDIF
  37.  
  38. _plineno=0          && set lines to zero
  39. *-- NOEJECT parameter
  40. IF gl_noeject
  41.    IF _peject="BEFORE"
  42.       _peject="NONE"
  43.    ENDIF
  44.    IF _peject="BOTH"
  45.       _peject="AFTER"
  46.    ENDIF
  47. ENDIF
  48.  
  49. *-- Set-up environment
  50. ON ESCAPE DO Prnabort
  51. IF SET("TALK")="ON"
  52.    SET TALK OFF
  53.    gc_talk="ON"
  54. ELSE
  55.    gc_talk="OFF"
  56. ENDIF
  57. gc_space=SET("SPACE")
  58. SET SPACE OFF
  59. gc_time=TIME()      && system time for predefined field
  60. gd_date=DATE()      && system date  "    "    "     "
  61. gl_fandl=.F.        && first and last page flag
  62. gl_intros=.F.       && flag for group intros on each page
  63. gl_prntflg=.T.      && Continue printing flag
  64. gl_widow=.T.        && flag for checking widow bands
  65. gn_length=LEN(gc_heading)  && store length of the HEADING
  66. gn_level=2          && current band being processed
  67. gn_page=_pageno     && grab current page number
  68. gn_pspace=_pspacing && get current print spacing
  69.  
  70. *-- Initialize group footer field variables
  71. r_foot1=.F.
  72.  
  73.  
  74. *-- Set up procedure for page break
  75. gn_atline=_plength - (_pspacing * 3 + 1)
  76. ON PAGE AT LINE gn_atline EJECT PAGE
  77.  
  78. *-- Print Report
  79.  
  80. PRINTJOB
  81.  
  82. *-- Initialize group break vars.
  83. r_mvar4=CUST_ID
  84.  
  85. *-- Initialize summary variables.
  86. r_msum1=0
  87. r_msum2=0
  88.  
  89. IF gl_plain
  90.    ON PAGE AT LINE gn_atline DO Pgplain
  91. ELSE
  92.    ON PAGE AT LINE gn_atline DO Pgfoot
  93. ENDIF
  94.  
  95. DO Pghead
  96.  
  97. gl_fandl=.T.        && first physical page started
  98.  
  99. DO Rintro
  100.  
  101. DO Grphead
  102. gl_intros=.F.
  103.  
  104. *-- File Loop
  105. DO WHILE FOUND() .AND. .NOT. EOF() .AND. gl_prntflg
  106.    DO CASE
  107.    CASE CUST_ID <> r_mvar4
  108.       gn_level=4
  109.    OTHERWISE
  110.       gn_level=0
  111.    ENDCASE
  112.    *-- test whether an expression didn't match
  113.    IF gn_level <> 0
  114.       DO Grpfoot WITH 100-gn_level
  115.       DO Grpinit
  116.    ENDIF
  117.    *-- Repeat group intros
  118.    IF gn_level <> 0
  119.       DO Grphead
  120.    ENDIF
  121.    gl_intros=.F.
  122.    gn_level=0
  123.    *-- Detail lines
  124.    IF gl_summary
  125.       DO Upd_Vars
  126.    ELSE
  127.       DO __Detail
  128.    ENDIF
  129.    gl_widow=.T.         && enable widow checking
  130.    CONTINUE
  131. ENDDO
  132.  
  133. IF gl_prntflg
  134.    gn_level=3
  135.    DO Grpfoot WITH 97
  136.    DO Rsumm
  137.    IF _plineno <= gn_atline
  138.       EJECT PAGE
  139.    ENDIF
  140. ELSE
  141.    gn_level=3
  142.    DO Rsumm
  143.    DO Reset
  144.    RETURN
  145. ENDIF
  146.  
  147. ON PAGE
  148.  
  149. ENDPRINTJOB
  150.  
  151. DO Reset
  152. RETURN
  153. * EOP: orders.FRG
  154.  
  155. *-- Determine height of group bands and detail band for widow checking
  156. FUNCTION Gheight
  157. PARAMETER Group_Band
  158. retval=0              && return value
  159. IF Group_Band <= 4
  160.    retval = retval + 2 * gn_pspace
  161. ENDIF
  162. *-- add height of detail band
  163. retval = retval + 5 * gn_pspace
  164. RETURN retval
  165. * EOP: Gheight
  166.  
  167. *-- Update summary fields and/or calculated fields.
  168. PROCEDURE Upd_Vars
  169. r_foot1=Cust_id
  170. *-- Count
  171. r_msum1=r_msum1+1
  172. *-- Count
  173. r_msum2=r_msum2+1
  174. RETURN
  175. * EOP: Upd_Vars
  176.  
  177. *-- Set flag to get out of DO WHILE loop when escape is pressed.
  178. PROCEDURE Prnabort
  179. gl_prntflg=.F.
  180. RETURN
  181. * EOP: Prnabort
  182.  
  183. *-- Reset group break variables.  Reinit summary
  184. *-- fields with reset set to a particular group band.
  185. PROCEDURE Grpinit
  186. IF gn_level <= 4
  187.    r_msum1=0
  188. ENDIF
  189. IF gn_level <= 4
  190.    r_mvar4=CUST_ID
  191. ENDIF
  192. RETURN
  193. * EOP: Grpinit
  194.  
  195. *-- Process Group Intro bands during group breaks
  196. PROCEDURE Grphead
  197. IF EOF()
  198.    RETURN
  199. ENDIF
  200. PRIVATE _pspacing
  201. _pspacing=gn_pspace
  202. IF gn_level = 0
  203.    gn_level=50
  204. ENDIF
  205. IF gn_level = 4
  206.    IF 2 * gn_pspace  < gn_atline
  207.       IF (gl_widow .AND. _plineno+Gheight(4) > gn_atline + 1) ;
  208.       .OR. (gl_widow .AND. _plineno+2 * gn_pspace > gn_atline)
  209.          EJECT PAGE
  210.       ENDIF
  211.    ENDIF
  212. ENDIF
  213. IF gn_level <= 4 .OR. gl_intros
  214.    DO Head4
  215. ENDIF
  216. gn_level=0
  217. RETURN
  218. * EOP: Grphead.PRG
  219.  
  220. *-- Process Group Summary bands during group breaks
  221. PROCEDURE Grpfoot
  222. PARAMETER ln_level
  223. IF ln_level >= 96
  224.    DO Foot96
  225. ENDIF
  226. RETURN
  227. * EOP: Grpfoot.PRG
  228.  
  229. PROCEDURE Pghead
  230. PRIVATE ll_heading, ln_width
  231. ll_heading = .T.
  232. ln_width = _rmargin - _lmargin
  233. ?
  234. *-- Print HEADING parameter - if it doesn't fit on line one
  235. *-- Value added to gn_length is the last column on line one times two
  236. IF .NOT. gl_plain .AND. gn_length + 160 > ln_width
  237.    ?? gc_heading FUNCTION "I;V"+LTRIM(STR(ln_width))
  238.    ?
  239.    ll_heading = .F.
  240. ENDIF
  241.  
  242. ?? IIF(gl_plain,'',gd_date) AT 0,;
  243.  IIF(gl_plain,'' , "PAGE " ) AT 71,;
  244.  IIF(gl_plain,'',_pageno) PICTURE "999" 
  245.  
  246. *-- Print HEADING parameter - if it fits on line one
  247. IF .NOT. gl_plain .AND. gn_length > 0 .AND. ll_heading
  248.    ?? " "
  249.    ?? gc_heading FUNCTION "I;V"+LTRIM(STR(ln_width-(_pcolno*2)))
  250. ENDIF
  251. ?
  252. ?
  253. ?
  254. RETURN
  255. * EOP: Pghead
  256.  
  257. PROCEDURE Rintro
  258. ?
  259. DEFINE BOX FROM 27 TO 56 HEIGHT 4 DOUBLE
  260. ?
  261. ?? "A-T FURNITURE INDUSTRIES" AT 30
  262. ?
  263. ?? "ORDERS REPORT" AT 35
  264. ?
  265. ?
  266. RETURN
  267. * EOP: Rintro
  268.  
  269. PROCEDURE Head4
  270. ?? ;
  271. "══════════════════════════════════════════════════════════════════════";
  272. + "═════════";
  273. AT 0
  274. ?
  275. ?? "CUSTOMER I.D.: " STYLE "BU" AT 0,;
  276.  Cust_id FUNCTION "T" STYLE "BU" 
  277. ?
  278. RETURN
  279.  
  280. PROCEDURE __Detail
  281. IF 5 * gn_pspace < gn_atline - (_pspacing * 4 + 1)
  282.    IF gl_widow .AND. _plineno+5 * gn_pspace > gn_atline + 1
  283.       EJECT PAGE
  284.       gl_intros=.F.
  285.    ENDIF
  286. ENDIF
  287. DO Upd_Vars
  288. ?? "ORDER DATE:  " AT 0,;
  289.  Date_trans ,;
  290.  "PART NUMBER: " AT 40,;
  291.  Part_id FUNCTION "T" ,;
  292.  "QUANTITY: " AT 66,;
  293.  Part_qty PICTURE "999" 
  294. ?
  295. ?? "P.O. NUMBER: " AT 0,;
  296.  Po_number FUNCTION "T" 
  297. ?
  298. ?? "SOLD BY EMPLOYEE: " AT 0,;
  299.  Emp_id FUNCTION "T" ,;
  300.  "INVOICED: " AT 66,;
  301.  Invoiced PICTURE "Y" AT 78
  302. ?
  303. ?? "NOTES: " AT 0,;
  304.  Notes FUNCTION "V64" AT 13
  305. ?
  306. ?? ;
  307. "──────────────────────────────────────────────────────────────────────";
  308. + "─────────";
  309. AT 0
  310. ?
  311. RETURN
  312. * EOP: __Detail
  313.  
  314. PROCEDURE Foot96
  315. ?? "NUMBER OF ORDERS FOR CUSTOMER " AT 0,;
  316.  r_foot1 FUNCTION "T" ,;
  317.  ": " ,;
  318.  r_msum1 PICTURE "999" 
  319. ?
  320. ?? ;
  321. "══════════════════════════════════════════════════════════════════════";
  322. + "═════════";
  323. AT 0
  324. ?
  325. ?
  326. RETURN
  327.  
  328. PROCEDURE Rsumm
  329. ?? "TOTAL NUMBER OF ORDERS: " AT 0,;
  330.  r_msum2 PICTURE "9,999" 
  331. ?
  332. ?? ;
  333. "══════════════════════════════════════════════════════════════════════";
  334. + "═════════";
  335. AT 0
  336. gl_fandl=.F.        && last page finished
  337. ?
  338. RETURN
  339. * EOP: Rsumm
  340.  
  341. PROCEDURE Pgfoot
  342. PRIVATE _box, _pspacing
  343. gl_widow=.F.         && disable widow checking
  344. _pspacing=1
  345. ?
  346. IF .NOT. gl_plain
  347.    _pspacing=gn_pspace
  348.    ?
  349.    ?? "PREPARED BY SALES DEPARTMENT" AT 28
  350.    ?
  351. ENDIF
  352. EJECT PAGE
  353. gl_intros=.T.
  354. *-- is the page number greater than the ending page
  355. IF _pageno > _pepage
  356.    GOTO BOTTOM
  357.    SKIP
  358.    gn_level=0
  359. ENDIF
  360. IF .NOT. gl_plain .AND. gl_fandl
  361.    _pspacing=gn_pspace
  362.    DO Pghead
  363.    IF gl_intros .AND. gn_level = 0
  364.      DO GrpHead
  365.      gl_newpage = .F.
  366.      gl_intros = .F.
  367.    ENDIF
  368. ENDIF
  369. RETURN
  370. * EOP: Pgfoot
  371.  
  372. *-- Process page break when PLAIN option is used.
  373. PROCEDURE Pgplain
  374. PRIVATE _box
  375. EJECT PAGE
  376. RETURN
  377. * EOP: Pgplain
  378.  
  379. *-- Reset dBASE environment prior to calling report
  380. PROCEDURE Reset
  381. SET SPACE &gc_space.
  382. SET TALK &gc_talk.
  383. ON ESCAPE
  384. ON PAGE
  385. RETURN
  386. * EOP: Reset
  387.  
  388.